home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swaga_c.zip / ARCHIVES.SWG / 0004_Code for LZH.PAS.pas < prev    next >
Pascal/Delphi Source File  |  1993-05-28  |  22KB  |  819 lines
  1.  
  2. Unit LZH;
  3.  
  4.  {$A+,B-,D-,E-,F-,I+,L-,N-,O-,R-,S-,V-}
  5.  
  6. (*
  7.  * LZHUF.C English version 1.0
  8.  * Based on Japanese version 29-NOV-1988
  9.  * LZSS coded by Haruhiko OKUMURA
  10.  * Adaptive Huffman Coding coded by Haruyasu YOSHIZAKI
  11.  * Edited and translated to English by Kenji RIKITAKE
  12.  * Translated from C to Turbo Pascal by Douglas Webb   2/18/91
  13.  *    Update and bug correction of TP version 4/29/91 (Sorry!!)
  14.  *)
  15.  
  16. {
  17.      This Unit allows the user to commpress data using a combination of
  18.    LZSS Compression and adaptive Huffman coding, or conversely to deCompress
  19.    data that was previously Compressed by this Unit.
  20.  
  21.      There are a number of options as to where the data being Compressed/
  22.    deCompressed is coming from/going to.
  23.  
  24.     In fact it requires that you pass the "LZHPack" Procedure 2 procedural
  25.   parameter of Type 'GetProcType' and 'PutProcType' (declared below) which
  26.   will accept 3 parameters and act in every way like a 'BlockRead'/'BlockWrite'
  27.   Procedure call. Your 'GetProcType' Procedure should return the data
  28.   to be Compressed, and Your 'PutProcType' Procedure should do something with
  29.   the Compressed data (ie., put it in a File).  In Case you need to know (and
  30.   you do if you want to deCompress this data again) the number of Bytes in the
  31.   Compressed data (original, not Compressed size) is returned in 'Bytes_Written'.
  32.  
  33.   GetBytesProc = Procedure(Var DTA; NBytes:Word; Var Bytes_Got : Word);
  34.   
  35.   DTA is the start of a memory location where the inFormation returned should
  36.   be.  NBytes is the number of Bytes requested.  The actual number of Bytes
  37.   returned must be passed in Bytes_Got (if there is no more data then 0
  38.   should be returned).
  39.  
  40.   PutBytesProc = Procedure(Var DTA; NBytes:Word; Var Bytes_Got : Word);
  41.  
  42.   As above except instead of asking For data the Procedure is dumping out
  43.   Compressed data, do somthing With it.
  44.  
  45.  
  46.     "LZHUnPack" is basically the same thing in reverse.  It requires
  47.   procedural parameters of Type 'PutProcType'/'GetProcType' which
  48.   will act as above.  'GetProcType' must retrieve data Compressed using
  49.   "LZHPack" (above) and feed it to the unpacking routine as requested.
  50.   'PutProcType' must accept the deCompressed data and do something
  51.   withit.  You must also pass in the original size of the deCompressed data,
  52.   failure to do so will have adverse results.
  53.  
  54.  
  55.      Don't Forget that as procedural parameters the 'GetProcType'/'PutProcType'
  56.   Procedures must be Compiled in the 'F+' state to avoid a catastrophe.
  57.  
  58.  
  59.  
  60. }
  61.  
  62. { note: All the large data structures For these routines are allocated when
  63.   needed from the heap, and deallocated when finished.  So when not in use
  64.   memory requirements are minimal.  However, this Unit Uses about 34K of
  65.   heap space, and 400 Bytes of stack when in use. }
  66.  
  67.  
  68. Interface
  69.  
  70. Type
  71.  
  72.  
  73.   PutBytesProc = Procedure(Var DTA; NBytes : Word; Var Bytes_Put : Word);
  74.   GetBytesProc = Procedure(Var DTA; NBytes : Word; Var Bytes_Got : Word);
  75.  
  76.  
  77.  
  78. Procedure LZHPack(Var Bytes_Written : LongInt;
  79.                       GetBytes : GetBytesProc;
  80.                       PutBytes : PutBytesProc);
  81.  
  82.  
  83. Procedure LZHUnpack(TextSize : LongInt;
  84.                     GetBytes : GetBytesProc;
  85.                     PutBytes : PutBytesProc);
  86.  
  87.  
  88. Implementation
  89.  
  90. Const
  91.   Exit_OK = 0;
  92.   Exit_FAILED = 1;
  93.  
  94.   { LZSS Parameters }
  95.   N = 4096;                            { Size of String buffer }
  96.   F = 60;                              { Size of look-ahead buffer }
  97.   THRESHOLD = 2;
  98.   NUL = N;                             { end of tree's node  }
  99.  
  100.   { Huffman coding parameters }
  101.   N_Char = (256 - THRESHOLD + F);
  102.  
  103.   { Character code (:= 0..N_Char-1) }
  104.   T = (N_Char * 2 - 1);                { Size of table }
  105.   R = (T - 1);                         { root position }
  106.  
  107.   { update when cumulative frequency }
  108.   { reaches to this value }
  109.   MAX_FREQ = $8000;
  110.  
  111. {
  112.  * Tables For encoding/decoding upper 6 bits of
  113.  * sliding dictionary Pointer
  114.  }
  115.  
  116.   { encoder table }
  117.   p_len : Array[0..63] of Byte =
  118.   ($03, $04, $04, $04, $05, $05, $05, $05,
  119.    $05, $05, $05, $05, $06, $06, $06, $06,
  120.    $06, $06, $06, $06, $06, $06, $06, $06,
  121.    $07, $07, $07, $07, $07, $07, $07, $07,
  122.    $07, $07, $07, $07, $07, $07, $07, $07,
  123.    $07, $07, $07, $07, $07, $07, $07, $07,
  124.    $08, $08, $08, $08, $08, $08, $08, $08,
  125.    $08, $08, $08, $08, $08, $08, $08, $08);
  126.  
  127.   p_code : Array[0..63] of Byte =
  128.   ($00, $20, $30, $40, $50, $58, $60, $68,
  129.    $70, $78, $80, $88, $90, $94, $98, $9C,
  130.    $A0, $A4, $A8, $AC, $B0, $B4, $B8, $BC,
  131.    $C0, $C2, $C4, $C6, $C8, $CA, $CC, $CE,
  132.    $D0, $D2, $D4, $D6, $D8, $DA, $DC, $DE,
  133.    $E0, $E2, $E4, $E6, $E8, $EA, $EC, $EE,
  134.    $F0, $F1, $F2, $F3, $F4, $F5, $F6, $F7,
  135.    $F8, $F9, $FA, $FB, $FC, $FD, $FE, $FF);
  136.  
  137.   { decoder table }
  138.   d_code : Array[0..255] of Byte =
  139.   ($00, $00, $00, $00, $00, $00, $00, $00,
  140.    $00, $00, $00, $00, $00, $00, $00, $00,
  141.    $00, $00, $00, $00, $00, $00, $00, $00,
  142.    $00, $00, $00, $00, $00, $00, $00, $00,
  143.    $01, $01, $01, $01, $01, $01, $01, $01,
  144.    $01, $01, $01, $01, $01, $01, $01, $01,
  145.    $02, $02, $02, $02, $02, $02, $02, $02,
  146.    $02, $02, $02, $02, $02, $02, $02, $02,
  147.    $03, $03, $03, $03, $03, $03, $03, $03,
  148.    $03, $03, $03, $03, $03, $03, $03, $03,
  149.    $04, $04, $04, $04, $04, $04, $04, $04,
  150.    $05, $05, $05, $05, $05, $05, $05, $05,
  151.    $06, $06, $06, $06, $06, $06, $06, $06,
  152.    $07, $07, $07, $07, $07, $07, $07, $07,
  153.    $08, $08, $08, $08, $08, $08, $08, $08,
  154.    $09, $09, $09, $09, $09, $09, $09, $09,
  155.    $0A, $0A, $0A, $0A, $0A, $0A, $0A, $0A,
  156.    $0B, $0B, $0B, $0B, $0B, $0B, $0B, $0B,
  157.    $0C, $0C, $0C, $0C, $0D, $0D, $0D, $0D,
  158.    $0E, $0E, $0E, $0E, $0F, $0F, $0F, $0F,
  159.    $10, $10, $10, $10, $11, $11, $11, $11,
  160.    $12, $12, $12, $12, $13, $13, $13, $13,
  161.    $14, $14, $14, $14, $15, $15, $15, $15,
  162.    $16, $16, $16, $16, $17, $17, $17, $17,
  163.    $18, $18, $19, $19, $1A, $1A, $1B, $1B,
  164.    $1C, $1C, $1D, $1D, $1E, $1E, $1F, $1F,
  165.    $20, $20, $21, $21, $22, $22, $23, $23,
  166.    $24, $24, $25, $25, $26, $26, $27, $27,
  167.    $28, $28, $29, $29, $2A, $2A, $2B, $2B,
  168.    $2C, $2C, $2D, $2D, $2E, $2E, $2F, $2F,
  169.    $30, $31, $32, $33, $34, $35, $36, $37,
  170.    $38, $39, $3A, $3B, $3C, $3D, $3E, $3F);
  171.  
  172.   d_len : Array[0..255] of Byte =
  173.   ($03, $03, $03, $03, $03, $03, $03, $03,
  174.    $03, $03, $03, $03, $03, $03, $03, $03,
  175.    $03, $03, $03, $03, $03, $03, $03, $03,
  176.    $03, $03, $03, $03, $03, $03, $03, $03,
  177.    $04, $04, $04, $04, $04, $04, $04, $04,
  178.    $04, $04, $04, $04, $04, $04, $04, $04,
  179.    $04, $04, $04, $04, $04, $04, $04, $04,
  180.    $04, $04, $04, $04, $04, $04, $04, $04,
  181.    $04, $04, $04, $04, $04, $04, $04, $04,
  182.    $04, $04, $04, $04, $04, $04, $04, $04,
  183.    $05, $05, $05, $05, $05, $05, $05, $05,
  184.    $05, $05, $05, $05, $05, $05, $05, $05,
  185.    $05, $05, $05, $05, $05, $05, $05, $05,
  186.    $05, $05, $05, $05, $05, $05, $05, $05,
  187.    $05, $05, $05, $05, $05, $05, $05, $05,
  188.    $05, $05, $05, $05, $05, $05, $05, $05,
  189.    $05, $05, $05, $05, $05, $05, $05, $05,
  190.    $05, $05, $05, $05, $05, $05, $05, $05,
  191.    $06, $06, $06, $06, $06, $06, $06, $06,
  192.    $06, $06, $06, $06, $06, $06, $06, $06,
  193.    $06, $06, $06, $06, $06, $06, $06, $06,
  194.    $06, $06, $06, $06, $06, $06, $06, $06,
  195.    $06, $06, $06, $06, $06, $06, $06, $06,
  196.    $06, $06, $06, $06, $06, $06, $06, $06,
  197.    $07, $07, $07, $07, $07, $07, $07, $07,
  198.    $07, $07, $07, $07, $07, $07, $07, $07,
  199.    $07, $07, $07, $07, $07, $07, $07, $07,
  200.    $07, $07, $07, $07, $07, $07, $07, $07,
  201.    $07, $07, $07, $07, $07, $07, $07, $07,
  202.    $07, $07, $07, $07, $07, $07, $07, $07,
  203.    $08, $08, $08, $08, $08, $08, $08, $08,
  204.    $08, $08, $08, $08, $08, $08, $08, $08);
  205.  
  206.   getbuf : Word = 0;
  207.   getlen : Byte = 0;
  208.   putlen : Byte = 0;
  209.   putbuf : Word = 0;
  210.   TextSize : LongInt = 0;
  211.   codesize : LongInt = 0;
  212.   printcount : LongInt = 0;
  213.   match_position : Integer = 0;
  214.   match_length : Integer = 0;
  215.  
  216.  
  217. Type
  218.   FreqType = Array[0..T] of Word; 
  219.   FreqPtr = ^FreqType;
  220.   PntrType = Array[0..pred(T + N_Char)] of Integer;
  221.   pntrPtr = ^PntrType;
  222.   SonType = Array[0..pred(T)] of Integer;
  223.   SonPtr = ^SonType;
  224.   TextBufType = Array[0..N + F - 2] of Byte;
  225.   TBufPtr = ^TextBufType;
  226.   WordRay = Array[0..N] of Integer;
  227.   WordRayPtr = ^WordRay;
  228.   BWordRay = Array[0..N + 256] of Integer;
  229.   BWordRayPtr = ^BWordRay;
  230.  
  231. Var
  232.   Text_buf : TBufPtr;
  233.   lson, dad : WordRayPtr;
  234.   rson : BWordRayPtr;
  235.   freq : FreqPtr;                      { cumulative freq table }
  236.  
  237. {
  238.  * pointing parent nodes.
  239.  * area [T..(T + N_Char - 1)] are Pointers For leaves
  240.  }
  241.   prnt : pntrPtr;
  242.  
  243.   { pointing children nodes (son[], son[] + 1)}
  244.   son : SonPtr;
  245.  
  246.  
  247.   Procedure InitTree;                  { Initializing tree }
  248.   Var
  249.     i : Integer;
  250.   begin
  251.     For i := N + 1 to N + 256 do
  252.       rson^[i] := NUL;                 { root }
  253.     For i := 0 to N do
  254.       dad^[i] := NUL;                  { node }
  255.   end;
  256.  
  257.  
  258.   Procedure InsertNode(R : Integer);   { Inserting node to the tree }
  259.   Var
  260.     tmp, i, p, cmp : Integer;
  261.     key : TBufPtr;
  262.     c : Word;
  263.   begin
  264.     cmp := 1;
  265.     key := @Text_buf^[R];
  266.     p := succ(N) + key^[0];
  267.     rson^[R] := NUL;
  268.     lson^[R] := NUL;
  269.     match_length := 0;
  270.     While match_length < F do
  271.       begin
  272.         if (cmp >= 0) then
  273.           begin
  274.             if (rson^[p] <> NUL) then
  275.               p := rson^[p]
  276.             else
  277.               begin
  278.                 rson^[p] := R;
  279.                 dad^[R] := p;
  280.                 Exit;
  281.               end;
  282.           end
  283.         else
  284.           begin
  285.             if (lson^[p] <> NUL) then
  286.               p := lson^[p]
  287.             else
  288.               begin
  289.                 lson^[p] := R;
  290.                 dad^[R] := p;
  291.                 Exit;
  292.               end;
  293.           end;
  294.         i := 0;
  295.         cmp := 0;
  296.         While (i < F) and (cmp = 0) do
  297.           begin
  298.             inc(i);
  299.             cmp := key^[i] - Text_buf^[p + i];
  300.           end;
  301.         if (i > THRESHOLD) then
  302.           begin
  303.             tmp := pred((R - p) and pred(N));
  304.             if (i > match_length) then
  305.               begin
  306.                 match_position := tmp;
  307.                 match_length := i;
  308.               end;
  309.             if (match_length < F) and (i = match_length) then
  310.               begin
  311.                 c := tmp;
  312.                 if (c < match_position) then
  313.                   match_position := c;
  314.               end;
  315.           end;
  316.       end;                             { While True do }
  317.     dad^[R] := dad^[p];
  318.     lson^[R] := lson^[p];
  319.     rson^[R] := rson^[p];
  320.     dad^[lson^[p]] := R;
  321.     dad^[rson^[p]] := R;
  322.     if (rson^[dad^[p]] = p) then
  323.       rson^[dad^[p]] := R
  324.     else
  325.       lson^[dad^[p]] := R;
  326.     dad^[p] := NUL;                    { remove p }
  327.   end;
  328.  
  329.  
  330.   Procedure DeleteNode(p : Integer);   { Deleting node from the tree }
  331.   Var
  332.     q : Integer;
  333.   begin
  334.     if (dad^[p] = NUL) then
  335.       Exit;                            { unregistered }
  336.     if (rson^[p] = NUL) then
  337.       q := lson^[p]
  338.     else if (lson^[p] = NUL) then
  339.       q := rson^[p]
  340.     else
  341.       begin
  342.         q := lson^[p];
  343.         if (rson^[q] <> NUL) then
  344.           begin
  345.             Repeat
  346.               q := rson^[q];
  347.             Until (rson^[q] = NUL);
  348.             rson^[dad^[q]] := lson^[q];
  349.             dad^[lson^[q]] := dad^[q];
  350.             lson^[q] := lson^[p];
  351.             dad^[lson^[p]] := q;
  352.           end;
  353.         rson^[q] := rson^[p];
  354.         dad^[rson^[p]] := q;
  355.       end;
  356.     dad^[q] := dad^[p];
  357.     if (rson^[dad^[p]] = p) then
  358.       rson^[dad^[p]] := q
  359.     else
  360.       lson^[dad^[p]] := q;
  361.     dad^[p] := NUL;
  362.   end;
  363.  
  364.   { Huffman coding parameters }
  365.  
  366.   Function GetBit(GetBytes : GetBytesProc) : Integer; { get one bit }
  367.   Var
  368.     i : Byte;
  369.     i2 : Integer;
  370.     result : Word;
  371.   begin
  372.     While (getlen <= 8) do
  373.       begin
  374.         GetBytes(i, 1, result);
  375.         if result = 1 then
  376.           i2 := i
  377.         else i2 := 0;
  378.         getbuf := getbuf or (i2 shl (8 - getlen));
  379.         inc(getlen, 8);
  380.       end;
  381.     i2 := getbuf;
  382.     getbuf := getbuf shl 1;
  383.     dec(getlen);
  384.     GetBit := Integer((i2 < 0));
  385.   end;
  386.  
  387.  
  388.   Function GetByte(GetBytes : GetBytesProc) : Integer; { get a Byte }
  389.   Var
  390.     j : Byte;
  391.     i, result : Word;
  392.   begin
  393.     While (getlen <= 8) do
  394.       begin
  395.         GetBytes(j, 1, result);
  396.         if result = 1 then
  397.           i := j
  398.         else
  399.           i := 0;
  400.         getbuf := getbuf or (i shl (8 - getlen));
  401.         inc(getlen, 8);
  402.       end;
  403.     i := getbuf;
  404.     getbuf := getbuf shl 8;
  405.     dec(getlen, 8);
  406.     GetByte := Integer(i shr 8);
  407.   end;
  408.  
  409.  
  410.   Procedure Putcode(l : Integer; c : Word;
  411.                     PutBytes : PutBytesProc); { output c bits }
  412.   Var
  413.     Temp : Byte;
  414.     Got : Word;
  415.   begin
  416.     putbuf := putbuf or (c shr putlen);
  417.     inc(putlen, l);
  418.     if (putlen >= 8) then
  419.       begin
  420.         Temp := putbuf shr 8;
  421.         PutBytes(Temp, 1, Got);
  422.         dec(putlen, 8);
  423.         if (putlen >= 8) then
  424.           begin
  425.             Temp := lo(putbuf);
  426.             PutBytes(Temp, 1, Got);
  427.             inc(codesize, 2);
  428.             dec(putlen, 8);
  429.             putbuf := c shl (l - putlen);
  430.           end
  431.         else
  432.           begin
  433.             putbuf := putbuf shl 8;
  434.             inc(codesize);
  435.           end;
  436.       end;
  437.   end;
  438.  
  439.  
  440.   { initialize freq tree }
  441.  
  442.   Procedure StartHuff;
  443.   Var
  444.     i, j : Integer;
  445.   begin
  446.     For i := 0 to pred(N_Char) do
  447.       begin
  448.         freq^[i] := 1;
  449.         son^[i] := i + T;
  450.         prnt^[i + T] := i;
  451.       end;
  452.     i := 0;
  453.     j := N_Char;
  454.     While (j <= R) do
  455.       begin
  456.         freq^[j] := freq^[i] + freq^[i + 1];
  457.         son^[j] := i;
  458.         prnt^[i] := j;
  459.         prnt^[i + 1] := j;
  460.         inc(i, 2);
  461.         inc(j);
  462.       end;
  463.     freq^[T] := $ffff;
  464.     prnt^[R] := 0;
  465.   end;
  466.  
  467.  
  468.   { reConstruct freq tree }
  469.  
  470.   Procedure reConst;
  471.   Var
  472.     i, j, k, tmp : Integer;
  473.     F, l : Word;
  474.   begin
  475.     { halven cumulative freq For leaf nodes }
  476.     j := 0;
  477.     For i := 0 to pred(T) do
  478.       begin
  479.         if (son^[i] >= T) then
  480.           begin
  481.             freq^[j] := succ(freq^[i]) div 2; {@@ Bug Fix MOD -> div @@}
  482.             son^[j] := son^[i];
  483.             inc(j);
  484.           end;
  485.       end;
  486.     { make a tree : first, connect children nodes }
  487.     i := 0;
  488.     j := N_Char;
  489.     While (j < T) do
  490.       begin
  491.         k := succ(i);
  492.         F := freq^[i] + freq^[k];
  493.         freq^[j] := F;
  494.         k := pred(j);
  495.         While F < freq^[k] do
  496.           dec(k);
  497.         inc(k);
  498.         l := (j - k) shl 1;
  499.         tmp := succ(k);
  500.         move(freq^[k], freq^[tmp], l);
  501.         freq^[k] := F;
  502.         move(son^[k], son^[tmp], l);
  503.         son^[k] := i;
  504.         inc(i, 2);
  505.         inc(j);
  506.       end;
  507.     { connect parent nodes }
  508.     For i := 0 to pred(T) do
  509.       begin
  510.         k := son^[i];
  511.         if (k >= T) then
  512.           begin
  513.             prnt^[k] := i;
  514.           end
  515.         else
  516.           begin
  517.             prnt^[k] := i;
  518.             prnt^[succ(k)] := i;
  519.           end;
  520.       end;
  521.   end;
  522.  
  523.  
  524.   { update freq tree }
  525.  
  526.   Procedure update(c : Integer);
  527.   Var
  528.     i, j, k, l : Integer;
  529.   begin
  530.     if (freq^[R] = MAX_FREQ) then
  531.       begin
  532.         reConst;
  533.       end;
  534.     c := prnt^[c + T];
  535.     Repeat
  536.       inc(freq^[c]);
  537.       k := freq^[c];
  538.       { swap nodes to keep the tree freq-ordered }
  539.       l := succ(c);
  540.       if (k > freq^[l]) then
  541.         begin
  542.           While (k > freq^[l]) do
  543.             inc(l);
  544.           dec(l);
  545.           freq^[c] := freq^[l];
  546.           freq^[l] := k;
  547.           i := son^[c];
  548.           prnt^[i] := l;
  549.           if (i < T) then prnt^[succ(i)] := l;
  550.           j := son^[l];
  551.           son^[l] := i;
  552.           prnt^[j] := c;
  553.           if (j < T) then prnt^[succ(j)] := c;
  554.           son^[c] := j;
  555.           c := l;
  556.         end;
  557.       c := prnt^[c];
  558.     Until (c = 0);                     { Repeat it Until reaching the root }
  559.   end;
  560.  
  561.  
  562. Var
  563.   code, len : Word;
  564.  
  565.   Procedure EncodeChar(c : Word; PutBytes : PutBytesProc);
  566.   Var
  567.     i : Word;
  568.     j, k : Integer;
  569.   begin
  570.     i := 0;
  571.     j := 0;
  572.     k := prnt^[c + T];
  573.     { search connections from leaf node to the root }
  574.     Repeat
  575.       i := i shr 1;
  576.  {
  577.         if node's address is odd, output 1
  578.         else output 0
  579.         }
  580.       if Boolean(k and 1) then inc(i, $8000);
  581.       inc(j);
  582.       k := prnt^[k];
  583.     Until (k = R);
  584.     Putcode(j, i, PutBytes);
  585.     code := i;
  586.     len := j;
  587.     update(c);
  588.   end;
  589.  
  590.  
  591.   Procedure EncodePosition(c : Word; PutBytes : PutBytesProc);
  592.   Var
  593.     i, j : Word;
  594.   begin
  595.     { output upper 6 bits With encoding }
  596.     i := c shr 6;
  597.     j := p_code[i];
  598.     Putcode(p_len[i], j shl 8, PutBytes);
  599.     { output lower 6 bits directly }
  600.     Putcode(6, (c and $3f) shl 10, PutBytes);
  601.   end;
  602.  
  603.  
  604.   Procedure Encodeend(PutBytes : PutBytesProc);
  605.   Var
  606.     Temp : Byte;
  607.     Got : Word;
  608.   begin
  609.     if Boolean(putlen) then
  610.       begin
  611.         Temp := lo(putbuf shr 8);
  612.         PutBytes(Temp, 1, Got);
  613.         inc(codesize);
  614.       end;
  615.   end;
  616.  
  617.  
  618.   Function DecodeChar(GetBytes : GetBytesProc) : Integer;
  619.   Var
  620.     c : Word;
  621.   begin
  622.     c := son^[R];
  623.     {
  624.      * start searching tree from the root to leaves.
  625.      * choose node #(son[]) if input bit = 0
  626.      * else choose #(son[]+1) (input bit = 1)
  627.     }
  628.     While (c < T) do
  629.       begin
  630.         c := c + GetBit(GetBytes);
  631.         c := son^[c];
  632.       end;
  633.     c := c - T;
  634.     update(c);
  635.     DecodeChar := Integer(c);
  636.   end;
  637.  
  638.  
  639.   Function DecodePosition(GetBytes : GetBytesProc) : Word;
  640.   Var
  641.     i, j, c : Word;
  642.   begin
  643.     { decode upper 6 bits from given table }
  644.     i := GetByte(GetBytes);
  645.     c := Word(d_code[i] shl 6);
  646.     j := d_len[i];
  647.     { input lower 6 bits directly }
  648.     dec(j, 2);
  649.     While j <> 0 do
  650.       begin
  651.         i := (i shl 1) + GetBit(GetBytes);
  652.         dec(j);
  653.       end;
  654.     DecodePosition := c or i and $3f;
  655.   end;
  656.  
  657.  
  658.   { Compression }
  659.  
  660.   Procedure InitLZH;
  661.   begin
  662.     getbuf := 0;
  663.     getlen := 0;
  664.     putlen := 0;
  665.     putbuf := 0;
  666.     TextSize := 0;
  667.     codesize := 0;
  668.     printcount := 0;
  669.     match_position := 0;
  670.     match_length := 0;
  671.     new(lson);
  672.     new(dad);
  673.     new(rson);
  674.     new(Text_buf);
  675.     new(freq);
  676.     new(prnt);
  677.     new(son);
  678.   end;
  679.  
  680.  
  681.   Procedure endLZH;
  682.   begin
  683.     dispose(son);
  684.     dispose(prnt);
  685.     dispose(freq);
  686.     dispose(Text_buf);
  687.     dispose(rson);
  688.     dispose(dad);
  689.     dispose(lson);
  690.   end;
  691.  
  692.  
  693.   Procedure LZHPack(Var Bytes_Written : LongInt;
  694.                         GetBytes : GetBytesProc;
  695.                         PutBytes : PutBytesProc);
  696.   Var
  697.     ct : Byte;
  698.     i, len, R, s, last_match_length : Integer;
  699.     Got : Word;
  700.   begin
  701.     InitLZH;
  702.     TextSize := 0;                     { rewind and rescan }
  703.     StartHuff;
  704.     InitTree;
  705.     s := 0;
  706.     R := N - F;
  707.     fillChar(Text_buf^[0], R, ' ');
  708.     len := 0;
  709.     Got := 1;
  710.     While (len < F) and (Got <> 0) do
  711.       begin
  712.         GetBytes(ct, 1, Got);
  713.         if Got <> 0 then
  714.           begin
  715.             Text_buf^[R + len] := ct;
  716.             inc(len);
  717.           end;
  718.       end;
  719.     TextSize := len;
  720.     For i := 1 to F do
  721.       InsertNode(R - i);
  722.     InsertNode(R);
  723.     Repeat
  724.       if (match_length > len) then
  725.         match_length := len;
  726.       if (match_length <= THRESHOLD) then
  727.         begin
  728.           match_length := 1;
  729.           EncodeChar(Text_buf^[R], PutBytes);
  730.         end
  731.       else
  732.         begin
  733.           EncodeChar(255 - THRESHOLD + match_length, PutBytes);
  734.           EncodePosition(match_position, PutBytes);
  735.         end;
  736.       last_match_length := match_length;
  737.       i := 0;
  738.       Got := 1;
  739.       While (i < last_match_length) and (Got <> 0) do
  740.         begin
  741.           GetBytes(ct, 1, Got);
  742.           if Got <> 0 then
  743.             begin
  744.               DeleteNode(s);
  745.               Text_buf^[s] := ct;
  746.               if (s < pred(F)) then
  747.                 Text_buf^[s + N] := ct;
  748.               s := succ(s) and pred(N);
  749.               R := succ(R) and pred(N);
  750.               InsertNode(R);
  751.               inc(i);
  752.             end;
  753.         end;
  754.       inc(TextSize, i);
  755.       While (i < last_match_length) do
  756.         begin
  757.           inc(i);
  758.           DeleteNode(s);
  759.           s := succ(s) and pred(N);
  760.           R := succ(R) and pred(N);
  761.           dec(len);
  762.           if Boolean(len) then InsertNode(R);
  763.         end;
  764.     Until (len <= 0);
  765.     Encodeend(PutBytes);
  766.     endLZH;
  767.     Bytes_Written := TextSize;
  768.   end;
  769.  
  770.  
  771.   Procedure LZHUnpack(TextSize : LongInt;
  772.                       GetBytes : GetBytesProc;
  773.                       PutBytes : PutBytesProc);
  774.   Var
  775.     c, i, j, k, R : Integer;
  776.     c2, a : Byte;
  777.     count : LongInt;
  778.     Put : Word;
  779.   begin
  780.     InitLZH;
  781.     StartHuff;
  782.     R := N - F;
  783.     fillChar(Text_buf^[0], R, ' ');
  784.     count := 0;
  785.     While count < TextSize do
  786.       begin
  787.         c := DecodeChar(GetBytes);
  788.         if (c < 256) then
  789.           begin
  790.             c2 := lo(c);
  791.             PutBytes(c2, 1, Put);
  792.             Text_buf^[R] := c;
  793.             inc(R);
  794.             R := R and pred(N);
  795.             inc(count);
  796.           end
  797.         else
  798.           begin
  799.             i := (R - succ(DecodePosition(GetBytes))) and pred(N);
  800.             j := c - 255 + THRESHOLD;
  801.             For k := 0 to pred(j) do
  802.               begin
  803.                 c := Text_buf^[(i + k) and pred(N)];
  804.                 c2 := lo(c);
  805.                 PutBytes(c2, 1, Put);
  806.                 Text_buf^[R] := c;
  807.                 inc(R);
  808.                 R := R and pred(N);
  809.                 inc(count);
  810.               end;
  811.           end;
  812.       end;
  813.     endLZH;
  814.   end;
  815.  
  816.  
  817. end.
  818.  
  819.